PC Open 92

home *** CD-ROM | disk | FTP | other *** search

/ PC Open 92 / PC Open 92 CD 1.bin / internet / AmphetaDesk / lib / AmphetaDesk / Utilities.pm < prev next >

Wrap

Perl POD Document | 2002-10-23 | 9.3 KB | 208 lines

package AmphetaDesk::Utilities; ############################################################################### # AmphetaDesk (c) 2000-2002 Disobey # # morbus@disobey.com http://www.disobey.com/amphetadesk/ # ############################################################################### # ABOUT THIS PACKAGE: # # This package contains all the minor utilities needed through out Ampheta, # # like logging, newline removable, HTML removal, and so on. None of these # # routines require knowledge of the AmphetaDesk SETTINGS, so use freely. # # # # LIST OF ROUTINES BELOW: # # encode_to_dec - encodes certain characters into decimal equivalents. # # get_response - returns the currently saved response array. # # note and error - send a message to our logfile. # # set_response - sets the response to user action in an array. # # strip_newlines_and_tabs - strips all newlines and tabs from incoming. # ############################################################################### # "Use freely? Bah! Wait until the RIAA gets their hands on it." # ############################################################################### use strict; $|++; use URI::Escape; require Exporter; use vars qw( @ISA @EXPORT ); @ISA = qw( Exporter ); @EXPORT = qw( encode_to_dec error get_response note set_response strip_newlines_and_tabs ); # where we store responses that should be shown # to the user based on their requested action. # see the get_ and set_response routines. my @RESPONSES; ############################################################################### # encode_to_dec - encodes certain characters into decimal equivalents. # ############################################################################### # USAGE: # # $modified = encode_to_dec( $data ); # # # # NOTES: # # Used to encode non-alphanumerics to decimal equivalents (like %20). # # # # RETURNS: # # $modified; the modified data, with non-alphanumerics encoded. # ############################################################################### sub encode_to_dec { my ($toencode) = @_; # what's a toe ncode? horrible hangnail? $toencode = uri_escape($toencode, "^a-zA-Z0-9_.-"); return $toencode; # what sort of song are we singing to enc? } ############################################################################### # get_response - returns the currently saved response array. # # set_response - sets the response to user action in an array. # ############################################################################### # USAGE: # # my @answers = get_response( ); # # set_response( "You've successfully added a channel!" ); # # # # NOTES: # # Returns the currently saved response, which is used for displaying # # diagnostic messages in the browser window (either in normal template # # pages, or in a javascript popup window. set_response will save a new # # response. get_response will remove the saved response(s) once retrieved. # # # # One way of handling the response is: # # my $response = join("<br />", get_response()); # # # # RETURNS: # # $value; the value of the passed or set. # # undef; if the setting doesn't exist or isn't defined. # ############################################################################### sub get_response { my @responses = @RESPONSES; undef @RESPONSES; # read once. return @responses; } sub set_response { my ($response) = @_; push (@RESPONSES, $response); } ############################################################################### # note and error - send a message to our logfile. # ############################################################################### # USAGE: # # note("This is a logged line. Yup."); sends to logfile. # # note("This is a logged line. Yup.", 1); sends to gui window also. # # note("This is added to @RESPONSES", 1, 1); add to our responses array. # # error("This is an error!"); die after logging. # # # # NOTES: # # You may use note to write a note to the gui window and LOG, and return # # happily. Whatever happens in the GUI portion is controlled by those # # libraries. error reaches into note, and exits the script when finished. # # # # RETURNS: # # 1; if the log was successfully written to. # ############################################################################### sub note { my ($message, $gui, $response) = @_; # what time is it, kenneth? my ($sec, $min, $hour) = localtime; $sec = sprintf "%02.0d", $sec; $min = sprintf "%02.0d", $min; $hour = sprintf "%02.0d", $hour; # print the entry to our log file. print LOG "[$hour:$min:$sec] $message\n"; # and save the message in our response log # if the message is also being sent to the gui. set_response($message) if $response; # if we've been told to pass it to our GUI, do so. # see cookbook 12.13. there are probably better # and smarter ways to do this, but I'm fed up. { no strict 'refs'; my $os; $os = "MacOSX" if $^O =~ /darwin/; $os = "MacOS" if $^O =~ /Mac/; $os = "Windows" if $^O =~ /Win/; $os = "Linux" unless defined $os; my $packname = "AmphetaDesk::OS::"; my $funcname = "::gui_note"; &{ $packname. $os . $funcname }($message) if $gui; } return 1; } sub error { my ($message) = @_; # send everywhere. note($message); # if we've been told to pass it to our GUI, do so. # see cookbook 12.13. there are probably better # and smarter ways to do this, but I'm fed up. { no strict 'refs'; my $os; $os = "MacOS" if $^O =~ /Mac/; $os = "Windows" if $^O =~ /Win/; $os = "Linux" unless defined $os; my $packname = "AmphetaDesk::OS::"; my $funcname = "::gui_note"; &{ $packname. $os . $funcname }($message); } # we sleep for 10 seconds so that the # error message is seen by someone. sleep 10; exit; } ############################################################################### # strip_newlines_and_tabs - strips all newlines and tabs from incoming. # ############################################################################### # USAGE: # # $modified = strip_newlines_and_tabs( $data ); # # # # NOTES: # # This routine removes newlines and tabs from the passed data. It can # # dip into arrays, single level hashes, and normal variables. It replaces # # all newlines and tabs with a single space character. # # # # RETURNS: # # $modified; the modified data, sans newlines and tabs. # ############################################################################### sub strip_newlines_and_tabs { my ($data) = @_; # depending on our data type, # process it differently. if (ref($data) eq "HASH") { foreach ( keys %{ $data } ) { next if not defined( $data->{$_} ); $data->{$_} =~ s/\n|\r|\f|\t/ /g if defined $data; } } elsif (ref($data) eq "ARRAY") { foreach ( @ { $data } ) { next if not defined( $data->[$_] ); $data->[$_] =~ s/\n|\r|\f|\t/ /g if defined $data; } } else { $data =~ s/\n|\r|\f|\t/ /g if defined $data; } return $data; } 1;